home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / mpfeel.lha / MPFeel / Modules / avl.em < prev    next >
Lisp/Scheme  |  1992-10-06  |  9KB  |  312 lines
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;;                                                                           ;;
  3. ;;  EuLisp Module                     Copyright (C) University of Bath 1991  ;;
  4. ;;                                                                           ;;
  5. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  6.  
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;
  9. ; File:         avl.em
  10. ; Title:        AVL tree module
  11. ; Author:       Julian Padget revised Arthur Norman's code.
  12. ;
  13. ; (c) Copyright 1990, University of Bath, all rights reserved
  14. ;
  15. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  16. ;
  17. ; Revisions:
  18. ;  21-APR-90 (Julian Padget)  Code originally comes from Cambridge Lisp and
  19. ;    was written by Arthur Norman.  Mohammed Awdeh and John Fitch made it work
  20. ;    in PSL and JAP tarted it up with defstruct and modules for EuLisp/PSL
  21. ;  10-NOV-90 (Julian Padget)  Rewrote instance of avl-prog to let or let*.
  22. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  23.  
  24. (defmodule avl
  25.  
  26.   ( lists list-operators ccc others macros0 extras0 avl-macros) ()
  27.  
  28.   ()
  29.  
  30.   (only
  31.     (values-in-tree keys-in-tree avlq-lookup avlq-add avlq-delete)
  32.     ( avl))
  33.  
  34.   ; this holds values for debugging purposes
  35.  
  36.   (deflocal avl-result nil)
  37.  
  38.   ; signifies a change in height of the tree
  39.  
  40.   (deflocal changed-height nil)
  41.  
  42.   ; Arbitrary comparitor...
  43.  
  44.   (defun avl-lookup (new-key tree)
  45.     (unless tree nil)
  46.     (avl-lookup1 new-key 
  47.          (avl-tree-tree tree) 
  48.          (avl-tree-order tree) 
  49.          (avl-tree-equality tree)))
  50.  
  51.   (defun avl-add (new-key tree)
  52.     (unless tree 
  53.       (setq tree (make-avl-tree 'order (lambda (a b) nil) 'equality equal)))
  54.     ((setter avl-tree-tree) tree 
  55.                             (avl-add1 new-key 
  56.                       (avl-tree-tree tree)
  57.                       (avl-tree-order tree) 
  58.                       (avl-tree-equality tree)))
  59.     tree)
  60.  
  61. ;  (defun avlr-add (new-key tree)
  62. ;    (unless tree
  63. ;      (setq tree (make-avl-tree 'order (lambda (a b) nil) 'equality equal)))
  64. ;    (avl-add1 new-key tree order (lambda (a b) nil)))
  65.  
  66.   (defun avl-delete (new-key tree)
  67.     ((setter avl-tree-tree) tree
  68.                             (avl-delete1 new-key 
  69.                      (avl-tree-tree tree)
  70.                      (avl-tree-order tree)
  71.                      (avl-tree-equality tree)))
  72.     tree)
  73.  
  74.   (export avl-lookup avl-add avlr-add avl-delete)
  75.  
  76.   ; three operations using eq to test
  77.  
  78.   ; (defun avlq-lookup (new-key tree order)
  79.   ;    (avl-lookup1 new-key tree order eq))
  80.  
  81.   ;  (defun avlq-add (new-key tree order)
  82.   ;    (avl-add1 new-key tree order eq))
  83.  
  84.   ;  (defun avlq-delete (new-key tree order)
  85.   ;    (avl-delete1 new-key tree order eq))
  86.  
  87.   ;  (export avlq-lookup avlq-add avlq-delete)
  88.  
  89.   ; flatten tree into list of keys
  90.  
  91.   (defun values-in-tree (tree) (values-in-tree1 (avl-tree-tree tree) nil))
  92.  
  93.   (defun keys-in-tree (tree) (values-in-tree2 (avl-tree-tree tree) nil))
  94.  
  95.   (export values-in-tree keys-in-tree)
  96.  
  97.   ; search tree for key satisfying predicate
  98.  
  99.   (defun avl-lookup1 (new-key tree order predicate)
  100.     (cond
  101.      ((null tree) nil)
  102.      ((predicate new-key (avl-key tree))
  103.       (key-value-pair tree))
  104.      ((order new-key (avl-key tree))
  105.       (avl-lookup1 new-key (avl-left tree) order predicate))
  106.      (t (avl-lookup1 new-key (avl-right tree) order predicate))))
  107.  
  108.   ; insert a new key into the tree
  109.  
  110.   (defun avl-add1 (new-key tree order predicate)
  111.     (cond
  112.      ((null tree)
  113.     (setq changed-height t)
  114.     (setq avl-result (make-key-value 'key new-key 'value nil))
  115.     (make-tree
  116.           'key-value-pair avl-result 'avl-left nil 
  117.       'avl-right nil 'balance-state 0))
  118.      ((predicate new-key (avl-key tree))
  119.     (setq changed-height nil)
  120.     (setq avl-result (key-value-pair tree))
  121.     tree)
  122.      ((order new-key (avl-key tree))
  123.     ((setter avl-left) tree
  124.               (avl-add1 new-key (avl-left tree) order predicate))
  125.     (cond
  126.      (changed-height
  127.       (cond
  128.        ((avl-balanced tree)
  129.         (mark-left-unbalanced tree))
  130.        ((avl-left-unbalanced tree)
  131.          (setq changed-height nil)
  132.          (mark-double-unbalanced tree)
  133.          (setq tree (rotate-right tree)))
  134.        (t
  135.            (setq changed-height nil)
  136.            (mark-balanced tree)))))
  137.     tree)
  138.      (t
  139.       ((setter avl-right) tree
  140.             (avl-add1 new-key (avl-right tree) order predicate))
  141.     (cond (changed-height
  142.            (cond ((avl-balanced tree)
  143.               (mark-right-unbalanced tree))
  144.              ((avl-right-unbalanced tree)
  145.               (setq changed-height nil)
  146.               (mark-double-unbalanced tree)
  147.               (setq tree (rotate-left tree)))
  148.              (t (setq changed-height nil)
  149.             (mark-balanced tree)))))
  150.     tree)))
  151.  
  152.   ; rebalance tree by left rotation (i.e. right child becomes root)
  153.  
  154.   (defun rotate-left (tree)
  155.     (let ((r (avl-right tree)) (q ()))
  156.       (when (avl-left-unbalanced r) (setq r (rotate-right r)))
  157.       (setq q (avl-left r))
  158.       ((setter avl-right) tree q)
  159.       ((setter avl-left) r tree)
  160.       (cond
  161.         ((avl-right-unbalanced r)
  162.          (if (avl-double-unbalanced tree)
  163.              (mark-balanced r)
  164.              (mark-left-unbalanced r))
  165.          (if (avl-right-unbalanced tree)
  166.              (mark-left-unbalanced tree)
  167.              (mark-balanced tree)))
  168.         (t
  169.          (mark-left-unbalanced r)
  170.          (mark-balanced tree)))
  171.       r))
  172.  
  173.   ; rebalance tree by left rotation (i.e. left child becomes root)
  174.  
  175.   (defun rotate-right (tree)
  176.     (let ((l (avl-left tree)) (q ()))
  177.       (setq l (avl-left tree))
  178.       (when (avl-right-unbalanced l) (setq l (rotate-left l)))
  179.       (setq q (avl-right l))
  180.       ((setter avl-left) tree q)
  181.       ((setter avl-right) l tree)
  182.       (cond
  183.         ((avl-left-unbalanced l)
  184.          (if (avl-double-unbalanced tree)
  185.              (mark-balanced l)
  186.          (mark-right-unbalanced l))
  187.          (if (avl-left-unbalanced tree)
  188.              (mark-right-unbalanced tree)
  189.          (mark-balanced tree)))
  190.         (t
  191.          (mark-right-unbalanced l)
  192.      (mark-balanced tree)))
  193.       l))
  194.  
  195.   ; remove key from tree
  196.  
  197.   (defun avl-delete1 (new-key tree order predicate)
  198.     (cond
  199.      ((null tree)
  200.       (setq changed-height nil)
  201.       (setq avl-result nil))
  202.      ((predicate new-key (avl-key tree))
  203.       (cond ((null (avl-left tree))
  204.          (setq changed-height t)
  205.          (setq avl-result (key-value-pair tree))
  206.          (avl-right tree))
  207.         ((null (avl-right tree))
  208.          (setq changed-height t)
  209.          (setq avl-result (key-value-pair tree))
  210.          (avl-left tree))
  211.         ((avl-balanced tree) (avl-delete2 tree order predicate))
  212.         ((avl-right-unbalanced tree)
  213.          (avl-delete1 new-key (rotate-left tree) order predicate))
  214.         (t (avl-delete1 new-key (rotate-right tree) order predicate))))
  215.      ((order new-key (avl-key tree))
  216.       ((setter avl-left) tree
  217.          (avl-delete1 new-key (avl-left tree) order predicate))
  218.       (when changed-height
  219.         (cond
  220.           ((avl-balanced tree)
  221.        (setq changed-height nil)
  222.            (mark-right-unbalanced tree))
  223.       ((avl-left-unbalanced tree)
  224.        (mark-balanced tree))
  225.       (t
  226.            (let ((r (avl-right tree)))
  227.              (when (avl-left-unbalanced r) (setq r (rotate-right r)))
  228.              ((setter avl-right) tree (avl-left r))
  229.          ((setter avl-left) r tree)
  230.          (cond
  231.                ((avl-balanced r)
  232.         (setq changed-height nil)
  233.         (mark-left-unbalanced r))
  234.                (t
  235.         (mark-balanced r)
  236.         (mark-balanced tree)))
  237.              (setq tree r)))))
  238.     tree)
  239.      (t
  240.       ((setter avl-right) tree
  241.          (avl-delete1 new-key (avl-right tree) order predicate))
  242.       (when changed-height
  243.         (cond
  244.           ((avl-balanced tree)
  245.            (setq changed-height nil)
  246.            (mark-left-unbalanced tree))
  247.           ((avl-right-unbalanced tree)
  248.        (mark-balanced tree))
  249.       (t
  250.            (let ((l (avl-left tree)))
  251.          (when (avl-right-unbalanced l) (setq l (rotate-left l)))
  252.          ((setter avl-left) tree (avl-right l))
  253.          ((setter avl-right) l tree)
  254.          (cond
  255.                ((avl-balanced l)
  256.         (setq changed-height nil)
  257.         (mark-right-unbalanced l))
  258.            (t
  259.                 (mark-balanced l)
  260.         (mark-balanced tree)))
  261.          (setq tree l)))))
  262.       tree)))
  263.  
  264.   ; used to deal with special case of when key to be deleted is the
  265.   ; root of a balanced tree
  266.  
  267.   (defun avl-delete2 (tree order predicate)
  268.     (let* ((r (avl-right tree)) (rl (avl-left r)))
  269.       (setq avl-result (key-value-pair tree))
  270.       (cond
  271.         ((null rl) 
  272.          ((setter avl-left) r (avl-left tree))
  273.      (mark-left-unbalanced r)
  274.      (setq changed-height nil)
  275.          r)
  276.         (t
  277.          (setq rl (leftmost-key rl))
  278.          ((setter avl-right) tree (avl-delete1 (car rl) r order predicate))
  279.          ((setter key-value-pair) tree rl)
  280.          (when changed-height (mark-left-unbalanced tree))
  281.          tree))))
  282.  
  283.   ; go left as far as possible
  284.  
  285.   (defun leftmost-key (tree)
  286.     (let ((l (avl-left tree)))
  287.       (if (null l) (key-value-pair tree) (leftmost-key l))))
  288.  
  289.   ; do in-order traversal constructing a list of the key-value pairs
  290.   ; in each node
  291.  
  292.   (defun values-in-tree1 (tree l)
  293.     (if (null tree)
  294.         l
  295.         (values-in-tree1
  296.       (avl-left tree)
  297.       (cons
  298.             (key-value-pair tree)
  299.             (values-in-tree1 (avl-right tree) l)))))
  300.  
  301.   ; do in-order traversal constructing a list of the keys in each node
  302.  
  303.   (defun values-in-tree2 (tree l)
  304.     (if (null tree)
  305.         l
  306.         (values-in-tree2
  307.       (avl-left tree)
  308.       (cons
  309.             (avl-key tree)
  310.             (values-in-tree2 (avl-right tree) l)))))
  311. )
  312.